home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 2 / Gold Medal Software Volume 2 (Gold Medal) (1994).iso / utils / dch.arj / DCH.PAS < prev    next >
Pascal/Delphi Source File  |  1993-08-25  |  4KB  |  129 lines
  1. program Dda_CHoice_clone;
  2. uses dos, crt ;
  3. const
  4.      progdata = 'DCH- Free DOS utility: batch file query.';
  5.      progdat2 = 'V1.00: August 25, 1993. (c) 1993 by David Daniel Anderson - Reign Ware.';
  6.        usage  = 'Usage:  DCH timeout_spec keys [text]';
  7. var
  8.      timestr     : string [7];
  9.      maxtime,
  10.      time        : word ;
  11.      timeout,
  12.      timeoutmode : boolean ;
  13.  
  14.      choices     : string ;
  15.  
  16.      selection   : char ;
  17.      errorlevel  : byte ;
  18.  
  19.      valerr      : integer ;
  20.  
  21. procedure showhelp ( errornum : byte );
  22. var
  23.     message : string [80];
  24. begin
  25.     normvideo ;
  26.     writeln(progdata);
  27.     writeln(progdat2);
  28.     writeln;
  29.     writeln(usage);
  30.     writeln;
  31.  
  32.     case errornum of
  33.       201 : message := 'you must have at least two parameters on the command line.';
  34.       202 : message := 'timeout value must be bracketed with a "[" and a "]".';
  35.       203 : message := 'timeout value must be a number between 0 and 65535.';
  36.       204 : message := 'if you SET DCHCLR, it must be a value between 0 and 255.';
  37.     end;
  38.     writeln ( 'ERROR: (#',errornum,') - ', message );
  39.     halt ( errornum );
  40. end;
  41.  
  42. procedure settextcolor ;
  43. var colorstr : string [3] ;
  44.     colorval,
  45.     valerr   : integer ;
  46. begin
  47.     colorstr := getenv ('dchclr');
  48.     if colorstr <> '' then begin
  49.        val ( colorstr, colorval, valerr ) ;
  50.        if valerr <> 0 then showhelp (204);
  51.        if colorval > 255 then showhelp (204);
  52.        textattr := colorval ;
  53.     end;
  54. end;
  55.  
  56. function gettext : string ;
  57. var
  58.    counter,
  59.    spaceplace : byte ;
  60.    cmdline : string ;
  61. begin
  62.    cmdline := string ( ptr ( prefixseg,$0080)^ );
  63.     { ^^ this line courtesy of Martin Richardson ^^ }
  64.  
  65.    for counter := 1 to 3 do begin
  66.        spaceplace := ( pos ( ' ',cmdline ));
  67.        cmdline := copy ( cmdline,
  68.                        ( spaceplace + 1 ),
  69.                        ( length (cmdline) - spaceplace ) );
  70.    end;
  71.    gettext := cmdline ;
  72. end;
  73.  
  74. begin
  75.      checkbreak := false ;
  76.      if paramcount < 2 then showhelp (201);
  77.      timeout := false ;
  78.      timeoutmode := false ;
  79.      timestr := paramstr (1);
  80.  
  81.      if ((timestr[1] <> '[')
  82.      or ((timestr [ length ( timestr ) ])  <> ']')) then showhelp (202);
  83.  
  84.      if length (timestr) <> 2 then begin
  85.         timeoutmode := true ;
  86.         time := 0 ;
  87.         timestr := copy ( timestr, 2, ( length ( timestr ) - 2) );
  88.         val ( timestr, maxtime, valerr ) ;
  89.         if valerr <> 0 then showhelp (203);
  90.         maxtime := 10 * maxtime ;
  91.         timeout := ( maxtime = 0 );
  92.      end;
  93.  
  94.      choices := paramstr (2);
  95.  
  96.      if paramcount > 2 then begin
  97.         settextcolor;
  98.         write ( gettext );
  99.      end ;
  100.  
  101.      if keypressed
  102.         then timeout := false
  103.              { so we can process a pending keystroke even }
  104.              { if the timeout parameter of [0] was used   }
  105.      else
  106.         while (( not keypressed ) and ( not timeout )) do begin
  107.             delay ( 95 );
  108.                   { if delay was 100, no time would be allowed for the loop }
  109.             if timeoutmode then begin
  110.                time := time + 1 ;
  111.                if time = maxtime then
  112.                   timeout := true ;
  113.             end; { if timeoutmode }
  114.         end; { while not keypressed ... }
  115.  
  116.      if not timeout then begin
  117.         selection := readkey ;
  118.         write ( selection );
  119.      end
  120.      else
  121.         selection := choices [1];
  122.  
  123.      errorlevel := ( pos ( selection , choices ) );
  124.      if errorlevel = 0 then errorlevel := 255 ;
  125.      if selection = '' then errorlevel := 0 ;
  126.      normvideo ;
  127.      halt ( errorlevel );
  128. end.
  129.